home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / Goodies / NEWINT~1 / OWNERD~1 / STATUS~1.CLS < prev    next >
Text File  |  1997-06-05  |  11KB  |  294 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CStatusBar32x"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10.  
  11.  
  12. Private hIcons(4) As Long 'Hold Icon Images so we don't have to keep hitting the harddrive
  13. Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
  14. Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  15. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  16. Private Declare Function DrawIconEx& Lib "user32" (ByVal hdc As Long, ByVal xleft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long)
  17. Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, _
  18. ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
  19. Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
  20. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  21. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  22. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  23. Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
  24. Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
  25. Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wcmd As Long) As Long
  26. Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
  27. Private Declare Function apiGetWindowDC& Lib "user32" Alias "GetWindowDC" (ByVal hwnd As Long)
  28. Private Declare Function apiGetDC& Lib "user32" Alias "GetDC" (ByVal hwnd As Long)
  29. Private Declare Function SendStringMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  30. Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
  31. Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
  32. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  33. Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
  34. Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
  35. Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
  36. Private StatBarWnd As Long
  37. Private Const ICC_BAR_CLASSES = &H4
  38. Private Const DI_NORMAL = 3
  39.  
  40.  
  41.  
  42. Public Enum sbAlignment
  43. Left = 1
  44. CENTER = 2
  45. Right = 3
  46. End Enum
  47.  
  48. Private Type tagInitCommonControlsEx
  49.     lngSize As Long
  50.     lngICC As Long
  51. End Type
  52.  
  53.   
  54. Const HWND_TOPMOST = -1
  55. Const SW_HIDE = 0
  56. Const SW_SHOWNORMAL = 1
  57.  
  58. Const SWP_SHOWWINDOW = &H40
  59.  
  60. ' Window Color constants
  61. Private Const COLOR_BTNFACE = 15
  62. Private Const COLOR_BTNTEXT = 18
  63. ' Window Style constants
  64. Const WS_VISIBLE = &H10000000
  65. Const WS_CHILD = &H40000000
  66.  
  67. ' CreateWindow constants
  68. Const CW_USEDEFAULT = &H80000000
  69. Private Const CCS_NORESIZE = &H4
  70. Private Const WM_PAINT = &HF
  71. Private Const SBARS_SIZEGRIP = &H100
  72. Private Const STATUSCLASSNAMEW = "msctls_statusbar32"
  73. Private Const WM_USER = &H400
  74. Private Const SB_SETTEXTA = (WM_USER + 1)
  75. Private Const SB_SETTEXTW = (WM_USER + 11)
  76. Private Const SB_GETTEXTA = (WM_USER + 2)
  77. Private Const SB_GETTEXTW = (WM_USER + 13)
  78. Private Const SB_GETTEXTLENGTHA = (WM_USER + 3)
  79. Private Const SB_GETTEXTLENGTHW = (WM_USER + 12)
  80. Private Const SB_GETTEXT = SB_GETTEXTW
  81. Private Const SB_SETTEXT = SB_SETTEXTW
  82. Private Const SB_GETTEXTLENGTH = SB_GETTEXTLENGTHW
  83. Private Const SB_SETPARTS = (WM_USER + 4)
  84. Private Const SB_GETPARTS = (WM_USER + 6)
  85. Private Const SB_GETBORDERS = (WM_USER + 7)
  86. Private Const SB_SETMINHEIGHT = (WM_USER + 8)
  87. Private Const SB_SIMPLE = (WM_USER + 9)
  88. Private Const SB_GETRECT = (WM_USER + 10)
  89. Private Const SB_ISSIMPLE = (WM_USER + 14)
  90. Private Const SBT_OWNERDRAW = &H1000
  91. Private Const SBT_NOBORDERS = &H100
  92. Private Const SBT_POPOUT = &H200
  93. Private Const SBT_RTLREADING = &H400
  94. Private Const SBT_STRECH = &H600
  95.  
  96.  
  97. Dim mfrmParent As Object
  98.  
  99. Public Function GetStatBarHwnd()
  100. GetStatBarHwnd = StatBarWnd
  101. End Function
  102.  
  103. Public Sub SetIcon(Pane As Integer, IconNum As Integer)
  104. On Error Resume Next
  105. Dim hLarge As Long, Retint As Long
  106. Retint = ExtractIconEx(App.Path & "\ODIcons.dll", IconNum, hLarge, hIcons(Pane), 2)
  107. End Sub
  108.  
  109. Public Sub UpdateStatBar(Pane As Integer)
  110. Dim l As Long
  111. Dim rc As RECT
  112.   Call SendMessage(StatBarWnd, SB_GETRECT, Pane, rc)
  113.   Call InvalidateRect(StatBarWnd, rc, True)
  114. End Sub
  115.  
  116. Public Sub DrawTextPic(Pane As Integer, strText As String, Optional IconNum As Integer, _
  117. Optional sbAlignment As sbAlignment = CENTER, Optional TextColor As ColorConstants = vbButtonText, _
  118. Optional fontbold As Boolean = False, Optional textoffset As Integer)
  119.   
  120. Dim hLarge As Long
  121. Dim hSmall As Long
  122. Dim Retint As Long
  123. Dim Rr As Long
  124. Dim k As Long
  125. Dim StatBarDC As Long
  126. Dim CurrentFont As Long, NewFont As Long
  127. Dim PaintBrush As Long, oldbrush As Long
  128. Dim dl As Long
  129. Dim BrushRect As RECT
  130. Dim StatBarRect As RECT
  131. Dim dt As DRAWTEXTPARAMS
  132. Dim lf As LOGFONT
  133. Dim TextAlign As Long
  134.    
  135.    'Make background transparent
  136.     dl = SetBkMode(StatBarDC, 0)
  137.     
  138.    'Fill drawtext params
  139.    dt.cbSize = LenB(dt)
  140.    dt.iTabLength = 0
  141.    dt.iLeftMargin = 0
  142.    dt.iRightMargin = 0
  143.    dt.uiLengthDrawn = 0
  144.  
  145.    StatBarDC = GetWindowDC(StatBarWnd)
  146.  
  147.    CurrentFont = SelectObject(StatBarDC, GetStockObject(SYSTEM_FONT))
  148.  
  149.      
  150.    lf.lffacename = "MS Sans Serif" & Chr$(0)
  151.    lf.lfHeight = 12
  152.    If fontbold = True Then
  153.    lf.lfWeight = 650
  154.    Else
  155.    lf.lfWeight = 500
  156.    End If
  157.    dl = SetTextColor(StatBarDC, TextColor)
  158.    
  159.    NewFont = CreateFontIndirect(lf)
  160.    dl = SelectObject(StatBarDC, NewFont)
  161.      
  162.    dl = SetBkMode(StatBarDC, 0)
  163.    
  164.    'Get dimensions of requested pane
  165.    Call SendMessage(StatBarWnd, SB_GETRECT, Pane, StatBarRect)
  166.    
  167.    'Form is sized too small and the pane is not visible then exit
  168.    If StatBarRect.Right - StatBarRect.Left <= 0 Then Exit Sub
  169.    
  170.    PaintBrush = CreateSolidBrush(GetSysColor(15)) 'System Button color
  171.   
  172.    'fill Pane with Brush of System Button Color
  173.    BrushRect.Top = StatBarRect.Top + 2
  174.    BrushRect.Left = StatBarRect.Left + 2
  175.    BrushRect.Right = StatBarRect.Right - 2
  176.    BrushRect.Bottom = StatBarRect.Bottom - 2
  177.    dl = FillRect(StatBarDC, BrushRect, PaintBrush)
  178.       
  179.    If sbAlignment = CENTER Then TextAlign = DT_CENTER
  180.    If sbAlignment = Left Then TextAlign = DT_LEFT
  181.    If sbAlignment = Right Then TextAlign = DT_RIGHT
  182.    
  183.    StatBarRect.Left = StatBarRect.Left + textoffset
  184.    StatBarRect.Right = StatBarRect.Right - 2
  185.    dl = DrawTextEx(StatBarDC, strText, Len(strText), StatBarRect, TextAlign Or DT_VCENTER& Or DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_PATH_ELLIPSIS Or DT_MODIFYSTRING, dt)
  186.    StatBarRect.Right = StatBarRect.Right + 2
  187.    StatBarRect.Left = StatBarRect.Left - textoffset
  188.    
  189.    Retint = DrawIconEx(StatBarDC, StatBarRect.Left + 3, 4, hIcons(Pane), 0, 0, 0, 0, DI_NORMAL)
  190.    'If you would rather use an imagelist
  191.    'Retint = DrawIconEx(StatBarDC, StatBarRect.Left + 3, 3, frmStatusBar.ImageList1.ListImages(1).ExtractIcon, 0, 0, 0, 0, DI_NORMAL)
  192.  
  193.   
  194.   
  195.    'Restore original font
  196.    NewFont = SelectObject(StatBarDC, CurrentFont)
  197.    'Restore original font
  198.    dl = SelectObject(StatBarDC, CurrentFont)
  199.    'And free up GDI objects
  200.    dl = DeleteObject(NewFont)
  201.    dl = DeleteObject(PaintBrush)
  202.  
  203.  
  204. End Sub
  205. Private Sub Class_Initialize()
  206.   Dim iccex As tagInitCommonControlsEx
  207.     With iccex
  208.         .lngSize = LenB(iccex)
  209.         .lngICC = ICC_BAR_CLASSES
  210.     End With
  211.     Call InitCommonControlsEx(iccex)
  212.  
  213.      StatBarWnd = 0 '
  214. End Sub
  215.  
  216.  
  217.  
  218. Public Sub Create()
  219.  
  220.  'Create StatusBar
  221.  StatBarWnd = CreateWindowEX(0&, _
  222.  "msctls_statusbar32", _
  223.  "", _
  224.  WS_CHILD Or WS_VISIBLE Or CCS_NORESIZE, _
  225.   0, 0, Parent.Width, 60, _
  226.  Parent.hwnd, 0&, App.hInstance, vbNull)
  227.  
  228.   
  229. Dim StatusBarPaneSize(4) As Long
  230.  
  231. StatusBarPaneSize(0) = 100
  232. StatusBarPaneSize(1) = 200
  233. StatusBarPaneSize(2) = 300
  234. StatusBarPaneSize(3) = 400
  235. StatusBarPaneSize(4) = -1
  236.  
  237. Dim Ret As Long
  238.  
  239. ' tell statusbar about number and size of panes
  240. Ret = SendMessage(StatBarWnd, SB_SETPARTS, 5, StatusBarPaneSize(0))
  241.  
  242. 'SBPS_STRETCH
  243. Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 0 Or SBT_POPOUT Or SBT_OWNERDRAW, "")
  244. Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 1 Or SBT_OWNERDRAW, "")
  245. Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 2 Or SBT_OWNERDRAW, "")
  246. Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 3 Or SBT_OWNERDRAW, "")
  247. Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, 4 Or SBT_OWNERDRAW, "")
  248.  
  249. Call ShowWindow(StatBarWnd, SW_SHOWNORMAL)
  250. Call SetParent(StatBarWnd, Parent.hwnd)
  251.  
  252. End Sub
  253. Public Property Get Parent() As Object
  254.     Set Parent = mfrmParent
  255. End Property
  256.  
  257. Public Property Set Parent(Frm As Object)
  258.     Set mfrmParent = Frm
  259. End Property
  260.  
  261.  
  262. Private Sub Class_Terminate()
  263.  Exit Sub
  264.     If StatBarWnd <> 0 Then
  265.         Call DestroyWindow(StatBarWnd)
  266.     End If
  267. End Sub
  268.  
  269. Public Sub DestroyStatBar()
  270. On Error Resume Next
  271.  
  272. If StatBarWnd <> 0 Then
  273.  
  274.         Call DestroyWindow(StatBarWnd)
  275.     End If
  276. End Sub
  277.  
  278. Public Sub Resize()
  279. On Error Resume Next
  280.   Call MoveWindow(StatBarWnd, 0, Parent.Height / Screen.TwipsPerPixelY - 49, Parent.Width / Screen.TwipsPerPixelX - 8, 22, True)
  281.    
  282.  
  283. End Sub
  284. Public Sub SetStatBarText(PaneNumber As Integer, StringToAdd As String)
  285.  Dim Ret As Long
  286.  'If you don't use SBT_OWNERDRAW flag when creating the
  287.  'Statubar, then you would update the pane with this call
  288.  'zero based pane number
  289.  Ret = SendStringMessage(StatBarWnd, SB_SETTEXTA, PaneNumber, StringToAdd)
  290.  Ret = UpdateWindow(StatBarWnd)
  291. End Sub
  292.  
  293.  
  294.